home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / peep-drv.em < prev    next >
Lisp/Scheme  |  1993-04-21  |  3KB  |  136 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: peep-drv.em
  4. ;; Date: Thu May 21 16:01:55 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule peep-drv
  11.   (standard0
  12.    list-fns
  13.    
  14.    stream
  15.    peephole
  16.    instruct
  17.    )
  18.   ()
  19.  
  20.   ;;;;;;;;;;;;;;;;;;;;;;
  21.   ;; Driver for all this
  22.   ;;
  23.   
  24.   ;; returns '(nochange lst)
  25.   ;;         '(change newlst rest)
  26.   
  27.   ;; cont is: (prev-list fn)
  28.   (defun optimize-lst (lst micro-opts-wanted)
  29.     (let* ((a-stream (make-simple-stream))
  30.        (stream (make-peep-stream a-stream micro-opts-wanted)))
  31.       (labels ((move-right (conts lst prev-code)
  32.                ;;(format t "Move: ~a ~a ~a~%" conts lst prev-code)
  33.                (if (null lst)
  34.                    (list 'no-change prev-code lst)
  35.                  (let ((extended-conts (extend-conts (car lst) 
  36.                                  (cons (list prev-code peep-test)
  37.                                        conts))))
  38.                    ;;(format t "Extended: ~a~%" extend-conts)
  39.                    (cond ((not (null (car extended-conts)))
  40.                       ;;(format t "New code: ~a~%" (car extended-conts))
  41.                       (list 'new 
  42.                         (append (make-prev-code (car extended-conts))
  43.                             (cdr lst))))
  44.                      ((null (cdr extended-conts))
  45.                       (list 'no-change
  46.                         (cons (car lst) prev-code)
  47.                         (cdr lst)))
  48.                      (t (move-right (cdr extended-conts)
  49.                             (cdr lst)
  50.                             (cons (car lst) prev-code)))))))
  51.            (opt-aux (lst)
  52.             ;;(format t "aux: ~a~%" lst)
  53.             (if (null lst) nil
  54.               (let ((res (move-right nil lst nil)))
  55.                 (cond ((eq (car res) 'no-change)
  56.                    ;;(format t "Code: ~a~%" (reverse (cadr res)))
  57.                    (write-stream-list stream (nreverse (cadr res)))
  58.                    (opt-aux (caddr res)))
  59.                   (t ;; (format t "Hacking again: ~a~%" (cadr res))
  60.                    (opt-aux (cadr res))))))))
  61.           (opt-aux lst)
  62.           (convert stream pair))))
  63.   
  64.   (export optimize-lst)
  65.  
  66.   ;; create the stream: if peephole optimisation is wanted, make a filter
  67.  
  68.   (defun make-peep-stream (stream microp)
  69.     (if microp
  70.     (make-filter-stream stream micro-optimise)
  71.       stream))
  72.  
  73.  
  74.  
  75.   (defun extend-conts (i lst)
  76.     ;;(format t "(Extend: ~a ~a~%" i lst)
  77.     (labels ((aux (conts code res)
  78.           ;;(format t "aux-1: ~a ~a ~a ~a ~%" i conts code res)
  79.           (if (null conts) 
  80.               (progn ;;(format t "Newcode: ~a~%" code)
  81.                  (cons code res))
  82.             (let ((ans ((cadar conts) i)))
  83.               (aux (cdr conts)
  84.                (append (mapcar (lambda (code)
  85.                          (list (reverse code) (caar conts)))
  86.                        (car ans))
  87.                    code)
  88.                (if (null (cdr ans))
  89.                    res
  90.                  (progn ;;(format t "new cont: ~a~%" ans)
  91.                     (cons (list (caar conts)
  92.                         (cdr ans))
  93.                       res))))))))
  94.         (let ((a (aux lst nil nil)))
  95.           ;;(format t ")~%")
  96.           a)))
  97.  
  98.   (defun make-new-cont (i prev)
  99.     (let ((res (peep-test i)))
  100.       (cons (car res)
  101.         (list prev (cdr res)))))
  102.   
  103.   
  104.   (defun make-prev-code (lst)
  105.     (labels ((aux (lst best-score best)
  106.           ;;(format t "Select: ~a ~a~%" best (if lst (car lst) nil))
  107.           (if (null lst)
  108.               (reverse best)
  109.             (let ((sc (score-code (caar lst))))
  110.               (if (< best-score sc)
  111.               (aux (cdr lst) best-score best)
  112.             (aux (cdr lst) sc (append (caar lst) (cadar lst))))))))
  113.         (aux (cdr lst)
  114.          (score-code (caar lst)) 
  115.          (append (caar lst) (cadar lst)))))
  116.   
  117.  
  118.   (defun score-code (l) 
  119.     (fold (lambda (i c)
  120.         (+ (i-cost i) c))
  121.       l 0))
  122.  
  123.  
  124.   ;;;;;
  125.   ;; Micro optimisation
  126.   ;; assumes 1->1 translation.
  127.   
  128.   (defun micro-optimise (i)
  129.     (let ((xx (micro-test i)))
  130.       (if (null (car xx)) i
  131.     (caar (car xx)))))
  132.  
  133.       
  134.   ;; end module
  135.   )
  136.